{-# LANGUAGE FlexibleInstances #-}
-----------------------------------------------------------------------------

--
-- Module      :  LLVM.Code.PPrint
-- Copyright   :  Mikhail Belyaev
-- License     :  GPL (Just (Version {versionBranch = [3], versionTags = []}))
--
-- Maintainer  :
-- Stability   :
-- Portability :
--
-- |
--
-----------------------------------------------------------------------------

module LLVM.Code.PPrint where


import LLVM.Code.Shared (BBIndex(..), ValIndex(..), TypeIndex(..), CmpOpcode(..), FCmpOpcode(..), ICmpOpcode(..))
import Data.List (intercalate)
import LLVM.Code.Module (Module(..), MiscModuleInfo(..))
import LLVM.Code.Values (ValueTable(..), Value(..), Value)
import Data.DataMap (Map,assocs)
import LLVM.Code.Constant (ConstantBlock(..), ConstantDef(..))
import Data.Maybe (fromJust, isJust)
import LLVM.Code.Symbolic (TypeSymbolTable(..), ValSymbolTable(..))
import LLVM.Code.Function
       (BasicBlock(..), FunctionTable(..), FunctionBodyDef(..))
import LLVM.Code.ParamAttrs (ParamBlock(..))
import LLVM.Code.Types (TypeTable(..), Type(..), Type)
import LLVM.Code.Values.Kinds
       (MetaValue(..), MetaValue, InstructionValue(..),
        FunctionDeclValue(..), ConstantValue(..), ConstantValue)
import LLVM.Code.Instructions.Values
       (DebugLoc(..), GetElementPtrInstruction(..), LoadInstruction(..),
        ReturnInstruction(..), StoreInstruction(..), CallInstruction(..),
        AllocaInstruction(..), CastInstruction(..), BinaryInstruction(..),
        BranchInstruction(..), CmpInstruction(..), Instruction(..))

data Printage = Inline String | Multiline [String] deriving (Show,Eq)

defaultPrint :: (Show a) => a -> String
defaultPrint = show

class PPrintable t where
    pprint :: t -> String

instance PPrintable TypeIndex where
    pprint (TypeIndex ti) = "$" ++ show ti

instance PPrintable ValIndex where
    pprint (ValIndex vi) = "%" ++ show vi

instance PPrintable BBIndex where
    pprint (BBIndex bi) = "bb#" ++ show bi

instance PPrintable Type where
    pprint LLVoid = "void"
    pprint (LLInt i) = "int" ++ show i
    pprint LLDouble =  "double"
    pprint LLFloat = "float"
    pprint LLFloat80 = "float80"
    pprint LLFloat128 = "float128"
    pprint (LLArray sz tp) = pprint tp ++ "[" ++ show sz ++ "]"
    pprint (LLVector sz tp) = "<" ++ pprint tp ++ ">[" ++ show sz ++ "]"
    pprint LLLabel = "label"
    pprint LLOpaque = "opaque"
    pprint LLMetadataType = "metadata"
    pprint (LLPointer tp asp) = pprint tp ++ "*" ++ if(asp /= 0) then "(AS" ++ show asp ++ ")"
                                                               else ""
    pprint (LLStruct tis pack) = let base = if(pack) then "packed"
                                                      else ""
                                  in base ++ "struct{" ++ intercalate "," (map pprint tis) ++ "}"
    pprint (LLFunctionType res pars vararg) =
        pprint res ++ "(" ++ intercalate "," (map pprint pars) ++ mod ++ ")"
        where mod = if(vararg == True) then "..."
                                      else ""

instance PPrintable TypeTable where
    pprint (TypeTable tt) = "Type table {\n" ++
        (intercalate ",\n" $ map (\(t,n) -> show n ++ ": " ++ pprint t) $ zip tt [0..] )
        ++ "\n}"

listCommasOrNone :: [String] -> String
listCommasOrNone [] = "none"
listCommasOrNone xs = intercalate "," xs

instance PPrintable MiscModuleInfo where
    pprint MiscModuleInfo {
                        version = version,
                        codeTriple = triple,
                        dataLayout = layout,
                        moduleAsm = asms,
                        codeSection = secs,
                        dependenceLib = depLibs,
                        gcName = gcs
                      } = "Module Info {\n" ++
                      "version: " ++ show version ++ "\n" ++
                      "code module triple: " ++ triple ++ "\n" ++
                      "data layout: " ++ layout ++ "\n" ++
                      "module asms: " ++ listCommasOrNone asms ++ "\n" ++
                      "code sections: " ++ listCommasOrNone secs ++ "\n" ++
                      "dependence libs: " ++ listCommasOrNone depLibs ++ "\n" ++
                      "used gc names: " ++ listCommasOrNone depLibs ++ "\n" ++
                      "}"

instance PPrintable Value where
    pprint (ConstantV i) = "constant # " ++ pprint i
    pprint (ParameterV i) = "function par # " ++ show i
    pprint (GlobalV i) = "global # " ++ show i
    pprint (AliasV i) = "alias # " ++ show i
    pprint (FunctionV i) = "function # " ++ pprint i
    pprint (MetaV i) = "meta # " ++ pprint i
    pprint (InstructionV (InstructionValue i dl)) = "instruction # " ++ pprint i ++
        case dl of
             Just (DebugLoc l c _ _) -> " // line " ++ show l ++ ", col " ++ show c
             _ -> ""

instance PPrintable MetaValue where
    pprint MetaAccessor{target = tgt} = "accessor to " ++ pprint tgt

instance PPrintable ConstantValue where
    pprint Null = "NULL"
    pprint Undefined = "undefined"
    pprint (IntegerC i) = show i
    pprint (FloatC fl) = show fl
    pprint (WIntegerC i) = show i
    pprint (Aggregate vs) = "aggregate{" ++ intercalate "," (map pprint vs) ++ "}"
    pprint (StringC str) = "\"" ++ str ++ "\""
    pprint (CStringC str) = "\"" ++ str ++ "\""
    pprint _ = "{..}" -- TODO

instance PPrintable FunctionDeclValue where
    pprint FunctionDeclValue{isAbstract=abs} = if abs then "declaration"
                                                      else "definition"



instance PPrintable (Type,Value) where
    pprint (tp,v) = pprint tp ++ " " ++ pprint v

instance PPrintable ValueTable where
    pprint (ValueTable mp) = "Value table {\n" ++
                             (intercalate ",\n" $ map (\(k,v) -> pprint k ++ "->" ++ pprint v) $ assocs mp) ++
                             "\n}"

instance PPrintable ConstantDef where
    pprint ConstantDef{ctype = tp, cvalue = cv} =
        show cv ++ " of type " ++ pprint tp

instance PPrintable ConstantBlock where
    pprint (ConstantBlock consts) = "Constants {\n" ++
                                    (intercalate ",\n" $ map pprint consts)++
                                    "\n}"

instance PPrintable ValSymbolTable where
    pprint ValSymbolTable{varNames = vars, bbNames = bbs} =
            "Value symbol table {\n" ++
            "values:\n" ++
            (intercalate ",\n" $ map (\(k,v) -> show k ++ "->" ++ v) $ assocs vars) ++
            "\nbasic blocks:\n" ++
            (intercalate ",\n" $ map (\(k,v) -> show k ++ "->" ++ v) $ assocs bbs) ++
            "}\n"

instance PPrintable TypeSymbolTable where
    pprint TypeSymbolTable{typeNames = tps} =
            "Type symbol table {\n" ++
            "types:\n" ++
            (intercalate ",\n" $ map (\(k,v) -> show k ++ "->" ++ v) $ assocs tps) ++
            "}\n"

instance PPrintable FunctionBodyDef where
    pprint FunctionBodyDef{
                     funcLocalValSyms = valsyms,
                     funcLocalVals = vals,
                     funcBasicBlocks = bbs
                     } =
             pprint valsyms ++ "\n" ++ pprint vals ++ "\n" ++ pprint bbs ++ "\n"

instance PPrintable FunctionTable where
    pprint ft = "Functions {\n" ++ (intercalate ",\n" $ map pprint $ bodies ft) ++ "\n}"

instance PPrintable (Map BBIndex BasicBlock) where
    pprint bbt = "Basic blocks  {\n" ++
            (intercalate ",\n" $ map (\(k,v) -> pprint k ++ "->" ++ pprint v) $ assocs bbt) ++
            "\n}\n"

instance PPrintable BasicBlock where
    pprint BasicBlock{bbFirst = fst, bbLast = lst, bbFollowing = fols, bbPreceeding = precs } =
        "(from " ++ pprint fst ++ " to " ++ pprint lst ++ ")" ++ " uses: " ++
        listCommasOrNone (map pprint fols) ++ "; used by: " ++
        listCommasOrNone (map pprint precs)

instance PPrintable ParamBlock where
    pprint = const "Parameter attributes { ... }"

instance PPrintable Module where
    pprint Module {
                typetable = typetable,
                valuetable = valuetable,
                miscInfo = miscInfo,
                functionBodies = functions,
                paramAttributes = paramAttributes,
                typeSymbols = typeSymbols,
                valSymbols = valSymbols
                -- raw :: [RawBlockElem]
              } = "Module {\n" ++
                 pprint miscInfo ++ "\n" ++
                 pprint typetable ++ "\n" ++
                 pprint valuetable ++ "\n" ++
                 pprint functions ++ "\n" ++
                 pprint paramAttributes ++ "\n" ++
                 pprint typeSymbols ++ "\n" ++
                 pprint valSymbols ++ "\n" ++
                 "\n}\n"


instance PPrintable Instruction where
    pprint (IBinary bin) = "bin <" ++ pprint (biType bin) ++ "> /" ++ show (biOpcode bin)
        ++ "/ (" ++ pprint (biOp1 bin) ++ ","
        ++ pprint (biOp2 bin) ++ ")"
    pprint (ICast cst) = "cast <" ++ pprint (ciOpType cst) ++ "->" ++ pprint (ciResType cst) ++
                         "> /" ++ show (ciOpcode cst) ++ "/ (" ++ pprint (ciOp cst) ++ ")"
    pprint (IAlloca al) = "alloca <" ++ pprint (allocaType al) ++ ">[" ++ pprint (allocaOp al) ++ "]"
    pprint (ICall cl) = "call <" ++ pprint (callType cl) ++ "> " ++ pprint (callFValue cl) ++
                "(" ++ (intercalate "," $ map pprint $ callOperands cl) ++ ")"
    pprint (IStore st) = "store <" ++ pprint (storePtType st) ++ ">(" ++ pprint (storeVal st) ++ "->>" ++
                            pprint (storePtr st) ++ ")"
    pprint (IRet rt) = "return" ++ case (result rt) of
                                       Nothing -> ""
                                       Just (t,v) -> "<" ++ pprint t ++ "> " ++ pprint v
    pprint (ILoad ld) = "load <" ++ pprint (loadPtType ld) ++ ">(" ++ pprint (loadPtr ld) ++ ")"
    pprint (IGEP gep) = "gep <" ++ pprint (gepValType gep) ++ "> " ++ pprint (gepVal gep)
                    ++ "(" ++ (intercalate "," $ map (\(x,y) -> pprint x ++ " " ++ pprint y) $ gepIxs gep) ++
                     ")"
    pprint (IBranch (CondBranch bbi0 bbi1 cond)) = "branch: <" ++ pprint cond ++ ">? " ++ pprint bbi0 ++ ":" ++ pprint bbi1
    pprint (IBranch (StraightBranch bbi)) = "branch: =>" ++ pprint bbi
    pprint (ICmp (CmpInstruction tp v1 v2 opcode)) = "cmp <" ++ pprint tp ++ ">(" ++ pprint v1 ++ " " ++ pprint opcode ++ " " ++ pprint v2 ++ ")"
    pprint x = show x


-- data CmpOpcode = FloatCmp FCmpOpcode | IntegerCmp ICmpOpcode  deriving (Show,Eq)

--data FCmpOpcode = FCmpFalse | FCmpOEQ | FCmpOGT | FCmpOGE | FCmpOLT | FCmpOLE | FCmpONE | FCmpORD |
--                    FCmpUEQ | FCmpUGT | FCmpUGE | FCmpULT | FCmpULE | FCmpUNE | FCmpTrue | FCmpBad

--data ICmpOpcode = ICmpEQ | ICmpNE | ICmpUGT | ICmpUGE | ICmpULT | ICmpULE |
--                          ICmpSGT | ICmpSGE | ICmpSLT | ICmpSLE | ICmpBad

instance PPrintable CmpOpcode where
    pprint (FloatCmp fopc) = case fopc of
                                  FCmpFalse -> "`false`"
                                  FCmpOEQ   -> "==of"
                                  FCmpOGT   -> ">of"
                                  FCmpOGE   -> ">=of"
                                  FCmpOLT   -> "<of"
                                  FCmpOLE   -> "<=of"
                                  FCmpONE   -> "!=of"
                                  FCmpORD   -> "???"
                                  FCmpUEQ   -> "==uf"
                                  FCmpUGT   -> ">uf"
                                  FCmpUGE   -> ">=uf"
                                  FCmpULT   -> "<uf"
                                  FCmpULE   -> "<=uf"
                                  FCmpUNE   -> "!=uf"        
                                  FCmpTrue  -> "`true`"  
                                  FCmpBad   -> "#bad#"                        

    pprint (IntegerCmp iopc) = case iopc of
                                    ICmpEQ  -> "=="
                                    ICmpNE  -> "!="
                                    ICmpUGT -> ">"
                                    ICmpUGE -> ">="
                                    ICmpULT -> "<"
                                    ICmpULE -> "<="
                                    ICmpSGT -> ">!"
                                    ICmpSGE -> ">=!"
                                    ICmpSLT -> "<!"
                                    ICmpSLE -> "<=!"
                                    ICmpBad -> "#bad#"























